home *** CD-ROM | disk | FTP | other *** search
/ Stone Design / Stone Design.iso / Stone_Friends / Wave / WavesWorld / Source / Libraries / tcl7.4b3 / tclExpr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-02-24  |  54.7 KB  |  2,094 lines
  1. /* 
  2.  * tclExpr.c --
  3.  *
  4.  *    This file contains the code to evaluate expressions for
  5.  *    Tcl.
  6.  *
  7.  *    This implementation of floating-point support was modelled
  8.  *    after an initial implementation by Bill Carpenter.
  9.  *
  10.  * Copyright (c) 1987-1994 The Regents of the University of California.
  11.  * Copyright (c) 1994 Sun Microsystems, Inc.
  12.  *
  13.  * See the file "license.terms" for information on usage and redistribution
  14.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15.  */
  16.  
  17. static char sccsid[] = "@(#) tclExpr.c 1.82 95/02/24 15:26:11";
  18.  
  19. #include "tclInt.h"
  20. #ifdef NO_FLOAT_H
  21. #   include "compat/float.h"
  22. #else
  23. #   include <float.h>
  24. #endif
  25. #ifndef TCL_NO_MATH
  26. #include <math.h>
  27. #endif
  28.  
  29. /*
  30.  * The stuff below is a bit of a hack so that this file can be used
  31.  * in environments that include no UNIX, i.e. no errno.  Just define
  32.  * errno here.
  33.  */
  34.  
  35. #ifndef TCL_GENERIC_ONLY
  36. #include "tclPort.h"
  37. extern int errno;
  38. #else
  39. #define NO_ERRNO_H
  40. #endif
  41.  
  42. #ifdef NO_ERRNO_H
  43. int errno;
  44. #define EDOM 33
  45. #define ERANGE 34
  46. #endif
  47.  
  48. /*
  49.  * The data structure below is used to describe an expression value,
  50.  * which can be either an integer (the usual case), a double-precision
  51.  * floating-point value, or a string.  A given number has only one
  52.  * value at a time.
  53.  */
  54.  
  55. #define STATIC_STRING_SPACE 150
  56.  
  57. typedef struct {
  58.     long intValue;        /* Integer value, if any. */
  59.     double  doubleValue;    /* Floating-point value, if any. */
  60.     ParseValue pv;        /* Used to hold a string value, if any. */
  61.     char staticSpace[STATIC_STRING_SPACE];
  62.                 /* Storage for small strings;  large ones
  63.                  * are malloc-ed. */
  64.     int type;            /* Type of value:  TYPE_INT, TYPE_DOUBLE,
  65.                  * or TYPE_STRING. */
  66. } Value;
  67.  
  68. /*
  69.  * Valid values for type:
  70.  */
  71.  
  72. #define TYPE_INT    0
  73. #define TYPE_DOUBLE    1
  74. #define TYPE_STRING    2
  75.  
  76. /*
  77.  * The data structure below describes the state of parsing an expression.
  78.  * It's passed among the routines in this module.
  79.  */
  80.  
  81. typedef struct {
  82.     char *originalExpr;        /* The entire expression, as originally
  83.                  * passed to Tcl_ExprString et al. */
  84.     char *expr;            /* Position to the next character to be
  85.                  * scanned from the expression string. */
  86.     int token;            /* Type of the last token to be parsed from
  87.                  * expr.  See below for definitions.
  88.                  * Corresponds to the characters just
  89.                  * before expr. */
  90. } ExprInfo;
  91.  
  92. /*
  93.  * The token types are defined below.  In addition, there is a table
  94.  * associating a precedence with each operator.  The order of types
  95.  * is important.  Consult the code before changing it.
  96.  */
  97.  
  98. #define VALUE        0
  99. #define OPEN_PAREN    1
  100. #define CLOSE_PAREN    2
  101. #define COMMA        3
  102. #define END        4
  103. #define UNKNOWN        5
  104.  
  105. /*
  106.  * Binary operators:
  107.  */
  108.  
  109. #define MULT        8
  110. #define DIVIDE        9
  111. #define MOD        10
  112. #define PLUS        11
  113. #define MINUS        12
  114. #define LEFT_SHIFT    13
  115. #define RIGHT_SHIFT    14
  116. #define LESS        15
  117. #define GREATER        16
  118. #define LEQ        17
  119. #define GEQ        18
  120. #define EQUAL        19
  121. #define NEQ        20
  122. #define BIT_AND        21
  123. #define BIT_XOR        22
  124. #define BIT_OR        23
  125. #define AND        24
  126. #define OR        25
  127. #define QUESTY        26
  128. #define COLON        27
  129.  
  130. /*
  131.  * Unary operators:
  132.  */
  133.  
  134. #define    UNARY_MINUS    28
  135. #define UNARY_PLUS    29
  136. #define NOT        30
  137. #define BIT_NOT        31
  138.  
  139. /*
  140.  * Precedence table.  The values for non-operator token types are ignored.
  141.  */
  142.  
  143. static int precTable[] = {
  144.     0, 0, 0, 0, 0, 0, 0, 0,
  145.     12, 12, 12,                /* MULT, DIVIDE, MOD */
  146.     11, 11,                /* PLUS, MINUS */
  147.     10, 10,                /* LEFT_SHIFT, RIGHT_SHIFT */
  148.     9, 9, 9, 9,                /* LESS, GREATER, LEQ, GEQ */
  149.     8, 8,                /* EQUAL, NEQ */
  150.     7,                    /* BIT_AND */
  151.     6,                    /* BIT_XOR */
  152.     5,                    /* BIT_OR */
  153.     4,                    /* AND */
  154.     3,                    /* OR */
  155.     2,                    /* QUESTY */
  156.     1,                    /* COLON */
  157.     13, 13, 13, 13            /* UNARY_MINUS, UNARY_PLUS, NOT,
  158.                      * BIT_NOT */
  159. };
  160.  
  161. /*
  162.  * Mapping from operator numbers to strings;  used for error messages.
  163.  */
  164.  
  165. static char *operatorStrings[] = {
  166.     "VALUE", "(", ")", ",", "END", "UNKNOWN", "6", "7",
  167.     "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=",
  168.     ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":",
  169.     "-", "+", "!", "~"
  170. };
  171.  
  172. /*
  173.  * The following slight modification to DBL_MAX is needed because of
  174.  * a compiler bug on Sprite (4/15/93).
  175.  */
  176.  
  177. #ifdef sprite
  178. #undef DBL_MAX
  179. #define DBL_MAX 1.797693134862316e+307
  180. #endif
  181.  
  182. /*
  183.  * Macros for testing floating-point values for certain special
  184.  * cases.  Test for not-a-number by comparing a value against
  185.  * itself;  test for infinity by comparing against the largest
  186.  * floating-point value.
  187.  */
  188.  
  189. #define IS_NAN(v) ((v) != (v))
  190. #ifdef DBL_MAX
  191. #   define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
  192. #else
  193. #   define IS_INF(v) 0
  194. #endif
  195.  
  196. /*
  197.  * The following global variable is use to signal matherr that Tcl
  198.  * is responsible for the arithmetic, so errors can be handled in a
  199.  * fashion appropriate for Tcl.  Zero means no Tcl math is in
  200.  * progress;  non-zero means Tcl is doing math.
  201.  */
  202.  
  203. int tcl_MathInProgress = 0;
  204.  
  205. /*
  206.  * The variable below serves no useful purpose except to generate
  207.  * a reference to matherr, so that the Tcl version of matherr is
  208.  * linked in rather than the system version.  Without this reference
  209.  * the need for matherr won't be discovered during linking until after
  210.  * libtcl.a has been processed, so Tcl's version won't be used.
  211.  */
  212.  
  213. #ifdef NEED_MATHERR
  214. extern int matherr();
  215. int (*tclMatherrPtr)() = matherr;
  216. #endif
  217.  
  218. /*
  219.  * Declarations for local procedures to this file:
  220.  */
  221.  
  222. static int        ExprAbsFunc _ANSI_ARGS_((ClientData clientData,
  223.                 Tcl_Interp *interp, Tcl_Value *args,
  224.                 Tcl_Value *resultPtr));
  225. static int        ExprBinaryFunc _ANSI_ARGS_((ClientData clientData,
  226.                 Tcl_Interp *interp, Tcl_Value *args,
  227.                 Tcl_Value *resultPtr));
  228. static int        ExprDoubleFunc _ANSI_ARGS_((ClientData clientData,
  229.                 Tcl_Interp *interp, Tcl_Value *args,
  230.                 Tcl_Value *resultPtr));
  231. static int        ExprGetValue _ANSI_ARGS_((Tcl_Interp *interp,
  232.                 ExprInfo *infoPtr, int prec, Value *valuePtr));
  233. static int        ExprIntFunc _ANSI_ARGS_((ClientData clientData,
  234.                 Tcl_Interp *interp, Tcl_Value *args,
  235.                 Tcl_Value *resultPtr));
  236. static int        ExprLex _ANSI_ARGS_((Tcl_Interp *interp,
  237.                 ExprInfo *infoPtr, Value *valuePtr));
  238. static int        ExprLooksLikeInt _ANSI_ARGS_((char *p));
  239. static void        ExprMakeString _ANSI_ARGS_((Tcl_Interp *interp,
  240.                 Value *valuePtr));
  241. static int        ExprMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
  242.                 ExprInfo *infoPtr, Value *valuePtr));
  243. static int        ExprParseString _ANSI_ARGS_((Tcl_Interp *interp,
  244.                 char *string, Value *valuePtr));
  245. static int        ExprRoundFunc _ANSI_ARGS_((ClientData clientData,
  246.                 Tcl_Interp *interp, Tcl_Value *args,
  247.                 Tcl_Value *resultPtr));
  248. static int        ExprTopLevel _ANSI_ARGS_((Tcl_Interp *interp,
  249.                 char *string, Value *valuePtr));
  250. static int        ExprUnaryFunc _ANSI_ARGS_((ClientData clientData,
  251.                 Tcl_Interp *interp, Tcl_Value *args,
  252.                 Tcl_Value *resultPtr));
  253.  
  254. /*
  255.  * Built-in math functions:
  256.  */
  257.  
  258. typedef struct {
  259.     char *name;            /* Name of function. */
  260.     int numArgs;        /* Number of arguments for function. */
  261.     Tcl_ValueType argTypes[MAX_MATH_ARGS];
  262.                 /* Acceptable types for each argument. */
  263.     Tcl_MathProc *proc;        /* Procedure that implements this function. */
  264.     ClientData clientData;    /* Additional argument to pass to the function
  265.                  * when invoking it. */
  266. } BuiltinFunc;
  267.  
  268. static BuiltinFunc funcTable[] = {
  269. #ifndef TCL_NO_MATH
  270.     {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
  271.     {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
  272.     {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
  273.     {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
  274.     {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
  275.     {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
  276.     {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh},
  277.     {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp},
  278.     {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor},
  279.     {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod},
  280.     {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot},
  281.     {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log},
  282.     {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10},
  283.     {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow},
  284.     {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin},
  285.     {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh},
  286.     {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt},
  287.     {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan},
  288.     {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh},
  289. #endif
  290.     {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
  291.     {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
  292.     {"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
  293.     {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
  294.  
  295.     {0},
  296. };
  297.  
  298. /*
  299.  *--------------------------------------------------------------
  300.  *
  301.  * ExprParseString --
  302.  *
  303.  *    Given a string (such as one coming from command or variable
  304.  *    substitution), make a Value based on the string.  The value
  305.  *    will be a floating-point or integer, if possible, or else it
  306.  *    will just be a copy of the string.
  307.  *
  308.  * Results:
  309.  *    TCL_OK is returned under normal circumstances, and TCL_ERROR
  310.  *    is returned if a floating-point overflow or underflow occurred
  311.  *    while reading in a number.  The value at *valuePtr is modified
  312.  *    to hold a number, if possible.
  313.  *
  314.  * Side effects:
  315.  *    None.
  316.  *
  317.  *--------------------------------------------------------------
  318.  */
  319.  
  320. static int
  321. ExprParseString(interp, string, valuePtr)
  322.     Tcl_Interp *interp;        /* Where to store error message. */
  323.     char *string;        /* String to turn into value. */
  324.     Value *valuePtr;        /* Where to store value information. 
  325.                  * Caller must have initialized pv field. */
  326. {
  327.     char *term, *p, *start;
  328.  
  329.     if (*string != 0) {
  330.     if (ExprLooksLikeInt(string)) {
  331.         valuePtr->type = TYPE_INT;
  332.         errno = 0;
  333.     
  334.         /*
  335.          * Note: use strtoul instead of strtol for integer conversions
  336.          * to allow full-size unsigned numbers, but don't depend on
  337.          * strtoul to handle sign characters;  it won't in some
  338.          * implementations.
  339.          */
  340.     
  341.         for (p = string; isspace(UCHAR(*p)); p++) {
  342.         /* Empty loop body. */
  343.         }
  344.         if (*p == '-') {
  345.         start = p+1;
  346.         valuePtr->intValue = -strtoul(start, &term, 0);
  347.         } else if (*p == '+') {
  348.         start = p+1;
  349.         valuePtr->intValue = strtoul(start, &term, 0);
  350.         } else {
  351.         start = p;
  352.         valuePtr->intValue = strtoul(start, &term, 0);
  353.         }
  354.         if (*term == 0) {
  355.         if (errno == ERANGE) {
  356.             /*
  357.              * This procedure is sometimes called with string in
  358.              * interp->result, so we have to clear the result before
  359.              * logging an error message.
  360.              */
  361.     
  362.             Tcl_ResetResult(interp);
  363.             interp->result = "integer value too large to represent";
  364.             Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
  365.                 interp->result, (char *) NULL);
  366.             return TCL_ERROR;
  367.         } else {
  368.             return TCL_OK;
  369.         }
  370.         }
  371.     } else {
  372.         errno = 0;
  373.         valuePtr->doubleValue = strtod(string, &term);
  374.  
  375.         /*
  376.          * The check against term[-1] below patches around a Solaris bug
  377.          * where strtod returns the wrong value in term.
  378.          */
  379.  
  380.         if ((term != string) && ((*term == 0) || (term[-1] == 0))) {
  381.         if (errno != 0) {
  382.             Tcl_ResetResult(interp);
  383.             TclExprFloatError(interp, valuePtr->doubleValue);
  384.             return TCL_ERROR;
  385.         }
  386.         valuePtr->type = TYPE_DOUBLE;
  387.         return TCL_OK;
  388.         }
  389.     }
  390.     }
  391.  
  392.     /*
  393.      * Not a valid number.  Save a string value (but don't do anything
  394.      * if it's already the value).
  395.      */
  396.  
  397.     valuePtr->type = TYPE_STRING;
  398.     if (string != valuePtr->pv.buffer) {
  399.     int length, shortfall;
  400.  
  401.     length = strlen(string);
  402.     valuePtr->pv.next = valuePtr->pv.buffer;
  403.     shortfall = length - (valuePtr->pv.end - valuePtr->pv.buffer);
  404.     if (shortfall > 0) {
  405.         (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall);
  406.     }
  407.     strcpy(valuePtr->pv.buffer, string);
  408.     }
  409.     return TCL_OK;
  410. }
  411.  
  412. /*
  413.  *----------------------------------------------------------------------
  414.  *
  415.  * ExprLex --
  416.  *
  417.  *    Lexical analyzer for expression parser:  parses a single value,
  418.  *    operator, or other syntactic element from an expression string.
  419.  *
  420.  * Results:
  421.  *    TCL_OK is returned unless an error occurred while doing lexical
  422.  *    analysis or executing an embedded command.  In that case a
  423.  *    standard Tcl error is returned, using interp->result to hold
  424.  *    an error message.  In the event of a successful return, the token
  425.  *    and field in infoPtr is updated to refer to the next symbol in
  426.  *    the expression string, and the expr field is advanced past that
  427.  *    token;  if the token is a value, then the value is stored at
  428.  *    valuePtr.
  429.  *
  430.  * Side effects:
  431.  *    None.
  432.  *
  433.  *----------------------------------------------------------------------
  434.  */
  435.  
  436. static int
  437. ExprLex(interp, infoPtr, valuePtr)
  438.     Tcl_Interp *interp;            /* Interpreter to use for error
  439.                      * reporting. */
  440.     register ExprInfo *infoPtr;        /* Describes the state of the parse. */
  441.     register Value *valuePtr;        /* Where to store value, if that is
  442.                      * what's parsed from string.  Caller
  443.                      * must have initialized pv field
  444.                      * correctly. */
  445. {
  446.     register char *p;
  447.     char *var, *term;
  448.     int result;
  449.  
  450.     p = infoPtr->expr;
  451.     while (isspace(UCHAR(*p))) {
  452.     p++;
  453.     }
  454.     if (*p == 0) {
  455.     infoPtr->token = END;
  456.     infoPtr->expr = p;
  457.     return TCL_OK;
  458.     }
  459.  
  460.     /*
  461.      * First try to parse the token as an integer or floating-point number.
  462.      * Don't want to check for a number if the first character is "+"
  463.      * or "-".  If we do, we might treat a binary operator as unary by
  464.      * mistake, which will eventually cause a syntax error.
  465.      */
  466.  
  467.     if ((*p != '+')  && (*p != '-')) {
  468.     if (ExprLooksLikeInt(p)) {
  469.         errno = 0;
  470.         valuePtr->intValue = strtoul(p, &term, 0);
  471.         if (errno == ERANGE) {
  472.         interp->result = "integer value too large to represent";
  473.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
  474.             interp->result, (char *) NULL);
  475.         return TCL_ERROR;
  476.         }
  477.         infoPtr->token = VALUE;
  478.         infoPtr->expr = term;
  479.         valuePtr->type = TYPE_INT;
  480.         return TCL_OK;
  481.     } else {
  482.         errno = 0;
  483.         valuePtr->doubleValue = strtod(p, &term);
  484.         if (term != p) {
  485.         if (errno != 0) {
  486.             TclExprFloatError(interp, valuePtr->doubleValue);
  487.             return TCL_ERROR;
  488.         }
  489.         if (term[-1] == 0) {
  490.             /*
  491.              * This corrects a bug in Solaris 2.4 whereby strtod
  492.              * miscalculates term for strings like "nan".
  493.              */
  494.             term--;
  495.         }
  496.         infoPtr->token = VALUE;
  497.         infoPtr->expr = term;
  498.         valuePtr->type = TYPE_DOUBLE;
  499.         return TCL_OK;
  500.         }
  501.     }
  502.     }
  503.  
  504.     infoPtr->expr = p+1;
  505.     switch (*p) {
  506.     case '$':
  507.  
  508.         /*
  509.          * Variable.  Fetch its value, then see if it makes sense
  510.          * as an integer or floating-point number.
  511.          */
  512.  
  513.         infoPtr->token = VALUE;
  514.         var = Tcl_ParseVar(interp, p, &infoPtr->expr);
  515.         if (var == NULL) {
  516.         return TCL_ERROR;
  517.         }
  518.         Tcl_ResetResult(interp);
  519.         if (((Interp *) interp)->noEval) {
  520.         valuePtr->type = TYPE_INT;
  521.         valuePtr->intValue = 0;
  522.         return TCL_OK;
  523.         }
  524.         return ExprParseString(interp, var, valuePtr);
  525.  
  526.     case '[':
  527.         infoPtr->token = VALUE;
  528.         ((Interp *) interp)->evalFlags = TCL_BRACKET_TERM;
  529.         result = Tcl_Eval(interp, p+1);
  530.         infoPtr->expr = ((Interp *) interp)->termPtr;
  531.         if (result != TCL_OK) {
  532.         return result;
  533.         }
  534.         infoPtr->expr++;
  535.         if (((Interp *) interp)->noEval) {
  536.         valuePtr->type = TYPE_INT;
  537.         valuePtr->intValue = 0;
  538.         Tcl_ResetResult(interp);
  539.         return TCL_OK;
  540.         }
  541.         result = ExprParseString(interp, interp->result, valuePtr);
  542.         if (result != TCL_OK) {
  543.         return result;
  544.         }
  545.         Tcl_ResetResult(interp);
  546.         return TCL_OK;
  547.  
  548.     case '"':
  549.         infoPtr->token = VALUE;
  550.         result = TclParseQuotes(interp, infoPtr->expr, '"', 0,
  551.             &infoPtr->expr, &valuePtr->pv);
  552.         if (result != TCL_OK) {
  553.         return result;
  554.         }
  555.         Tcl_ResetResult(interp);
  556.         return ExprParseString(interp, valuePtr->pv.buffer, valuePtr);
  557.  
  558.     case '{':
  559.         infoPtr->token = VALUE;
  560.         result = TclParseBraces(interp, infoPtr->expr, &infoPtr->expr,
  561.             &valuePtr->pv);
  562.         if (result != TCL_OK) {
  563.         return result;
  564.         }
  565.         Tcl_ResetResult(interp);
  566.         return ExprParseString(interp, valuePtr->pv.buffer, valuePtr);
  567.  
  568.     case '(':
  569.         infoPtr->token = OPEN_PAREN;
  570.         return TCL_OK;
  571.  
  572.     case ')':
  573.         infoPtr->token = CLOSE_PAREN;
  574.         return TCL_OK;
  575.  
  576.     case ',':
  577.         infoPtr->token = COMMA;
  578.         return TCL_OK;
  579.  
  580.     case '*':
  581.         infoPtr->token = MULT;
  582.         return TCL_OK;
  583.  
  584.     case '/':
  585.         infoPtr->token = DIVIDE;
  586.         return TCL_OK;
  587.  
  588.     case '%':
  589.         infoPtr->token = MOD;
  590.         return TCL_OK;
  591.  
  592.     case '+':
  593.         infoPtr->token = PLUS;
  594.         return TCL_OK;
  595.  
  596.     case '-':
  597.         infoPtr->token = MINUS;
  598.         return TCL_OK;
  599.  
  600.     case '?':
  601.         infoPtr->token = QUESTY;
  602.         return TCL_OK;
  603.  
  604.     case ':':
  605.         infoPtr->token = COLON;
  606.         return TCL_OK;
  607.  
  608.     case '<':
  609.         switch (p[1]) {
  610.         case '<':
  611.             infoPtr->expr = p+2;
  612.             infoPtr->token = LEFT_SHIFT;
  613.             break;
  614.         case '=':
  615.             infoPtr->expr = p+2;
  616.             infoPtr->token = LEQ;
  617.             break;
  618.         default:
  619.             infoPtr->token = LESS;
  620.             break;
  621.         }
  622.         return TCL_OK;
  623.  
  624.     case '>':
  625.         switch (p[1]) {
  626.         case '>':
  627.             infoPtr->expr = p+2;
  628.             infoPtr->token = RIGHT_SHIFT;
  629.             break;
  630.         case '=':
  631.             infoPtr->expr = p+2;
  632.             infoPtr->token = GEQ;
  633.             break;
  634.         default:
  635.             infoPtr->token = GREATER;
  636.             break;
  637.         }
  638.         return TCL_OK;
  639.  
  640.     case '=':
  641.         if (p[1] == '=') {
  642.         infoPtr->expr = p+2;
  643.         infoPtr->token = EQUAL;
  644.         } else {
  645.         infoPtr->token = UNKNOWN;
  646.         }
  647.         return TCL_OK;
  648.  
  649.     case '!':
  650.         if (p[1] == '=') {
  651.         infoPtr->expr = p+2;
  652.         infoPtr->token = NEQ;
  653.         } else {
  654.         infoPtr->token = NOT;
  655.         }
  656.         return TCL_OK;
  657.  
  658.     case '&':
  659.         if (p[1] == '&') {
  660.         infoPtr->expr = p+2;
  661.         infoPtr->token = AND;
  662.         } else {
  663.         infoPtr->token = BIT_AND;
  664.         }
  665.         return TCL_OK;
  666.  
  667.     case '^':
  668.         infoPtr->token = BIT_XOR;
  669.         return TCL_OK;
  670.  
  671.     case '|':
  672.         if (p[1] == '|') {
  673.         infoPtr->expr = p+2;
  674.         infoPtr->token = OR;
  675.         } else {
  676.         infoPtr->token = BIT_OR;
  677.         }
  678.         return TCL_OK;
  679.  
  680.     case '~':
  681.         infoPtr->token = BIT_NOT;
  682.         return TCL_OK;
  683.  
  684.     default:
  685.         if (isalpha(UCHAR(*p))) {
  686.         infoPtr->expr = p;
  687.         return ExprMathFunc(interp, infoPtr, valuePtr);
  688.         }
  689.         infoPtr->expr = p+1;
  690.         infoPtr->token = UNKNOWN;
  691.         return TCL_OK;
  692.     }
  693. }
  694.  
  695. /*
  696.  *----------------------------------------------------------------------
  697.  *
  698.  * ExprGetValue --
  699.  *
  700.  *    Parse a "value" from the remainder of the expression in infoPtr.
  701.  *
  702.  * Results:
  703.  *    Normally TCL_OK is returned.  The value of the expression is
  704.  *    returned in *valuePtr.  If an error occurred, then interp->result
  705.  *    contains an error message and TCL_ERROR is returned.
  706.  *    InfoPtr->token will be left pointing to the token AFTER the
  707.  *    expression, and infoPtr->expr will point to the character just
  708.  *    after the terminating token.
  709.  *
  710.  * Side effects:
  711.  *    None.
  712.  *
  713.  *----------------------------------------------------------------------
  714.  */
  715.  
  716. static int
  717. ExprGetValue(interp, infoPtr, prec, valuePtr)
  718.     Tcl_Interp *interp;            /* Interpreter to use for error
  719.                      * reporting. */
  720.     register ExprInfo *infoPtr;        /* Describes the state of the parse
  721.                      * just before the value (i.e. ExprLex
  722.                      * will be called to get first token
  723.                      * of value). */
  724.     int prec;                /* Treat any un-parenthesized operator
  725.                      * with precedence <= this as the end
  726.                      * of the expression. */
  727.     Value *valuePtr;            /* Where to store the value of the
  728.                      * expression.   Caller must have
  729.                      * initialized pv field. */
  730. {
  731.     Interp *iPtr = (Interp *) interp;
  732.     Value value2;            /* Second operand for current
  733.                      * operator.  */
  734.     int operator;            /* Current operator (either unary
  735.                      * or binary). */
  736.     int badType;            /* Type of offending argument;  used
  737.                      * for error messages. */
  738.     int gotOp;                /* Non-zero means already lexed the
  739.                      * operator (while picking up value
  740.                      * for unary operator).  Don't lex
  741.                      * again. */
  742.     int result;
  743.  
  744.     /*
  745.      * There are two phases to this procedure.  First, pick off an initial
  746.      * value.  Then, parse (binary operator, value) pairs until done.
  747.      */
  748.  
  749.     gotOp = 0;
  750.     value2.pv.buffer = value2.pv.next = value2.staticSpace;
  751.     value2.pv.end = value2.pv.buffer + STATIC_STRING_SPACE - 1;
  752.     value2.pv.expandProc = TclExpandParseValue;
  753.     value2.pv.clientData = (ClientData) NULL;
  754.     result = ExprLex(interp, infoPtr, valuePtr);
  755.     if (result != TCL_OK) {
  756.     goto done;
  757.     }
  758.     if (infoPtr->token == OPEN_PAREN) {
  759.  
  760.     /*
  761.      * Parenthesized sub-expression.
  762.      */
  763.  
  764.     result = ExprGetValue(interp, infoPtr, -1, valuePtr);
  765.     if (result != TCL_OK) {
  766.         goto done;
  767.     }
  768.     if (infoPtr->token != CLOSE_PAREN) {
  769.         Tcl_AppendResult(interp, "unmatched parentheses in expression \"",
  770.             infoPtr->originalExpr, "\"", (char *) NULL);
  771.         result = TCL_ERROR;
  772.         goto done;
  773.     }
  774.     } else {
  775.     if (infoPtr->token == MINUS) {
  776.         infoPtr->token = UNARY_MINUS;
  777.     }
  778.     if (infoPtr->token == PLUS) {
  779.         infoPtr->token = UNARY_PLUS;
  780.     }
  781.     if (infoPtr->token >= UNARY_MINUS) {
  782.  
  783.         /*
  784.          * Process unary operators.
  785.          */
  786.  
  787.         operator = infoPtr->token;
  788.         result = ExprGetValue(interp, infoPtr, precTable[infoPtr->token],
  789.             valuePtr);
  790.         if (result != TCL_OK) {
  791.         goto done;
  792.         }
  793.         if (!iPtr->noEval) {
  794.         switch (operator) {
  795.             case UNARY_MINUS:
  796.             if (valuePtr->type == TYPE_INT) {
  797.                 if (valuePtr->intValue == LONG_MIN) {
  798.                 goto integerOverflow;
  799.                 }
  800.                 valuePtr->intValue = -valuePtr->intValue;
  801.             } else if (valuePtr->type == TYPE_DOUBLE){
  802.                 valuePtr->doubleValue = -valuePtr->doubleValue;
  803.             } else {
  804.                 badType = valuePtr->type;
  805.                 goto illegalType;
  806.             } 
  807.             break;
  808.             case UNARY_PLUS:
  809.             if ((valuePtr->type != TYPE_INT)
  810.                 && (valuePtr->type != TYPE_DOUBLE)) {
  811.                 badType = valuePtr->type;
  812.                 goto illegalType;
  813.             } 
  814.             break;
  815.             case NOT:
  816.             if (valuePtr->type == TYPE_INT) {
  817.                 valuePtr->intValue = !valuePtr->intValue;
  818.             } else if (valuePtr->type == TYPE_DOUBLE) {
  819.                 /*
  820.                  * Theoretically, should be able to use
  821.                  * "!valuePtr->intValue", but apparently some
  822.                  * compilers can't handle it.
  823.                  */
  824.                 if (valuePtr->doubleValue == 0.0) {
  825.                 valuePtr->intValue = 1;
  826.                 } else {
  827.                 valuePtr->intValue = 0;
  828.                 }
  829.                 valuePtr->type = TYPE_INT;
  830.             } else {
  831.                 badType = valuePtr->type;
  832.                 goto illegalType;
  833.             }
  834.             break;
  835.             case BIT_NOT:
  836.             if (valuePtr->type == TYPE_INT) {
  837.                 valuePtr->intValue = ~valuePtr->intValue;
  838.             } else {
  839.                 badType  = valuePtr->type;
  840.                 goto illegalType;
  841.             }
  842.             break;
  843.         }
  844.         }
  845.         gotOp = 1;
  846.     } else if (infoPtr->token != VALUE) {
  847.         goto syntaxError;
  848.     }
  849.     }
  850.  
  851.     /*
  852.      * Got the first operand.  Now fetch (operator, operand) pairs.
  853.      */
  854.  
  855.     if (!gotOp) {
  856.     result = ExprLex(interp, infoPtr, &value2);
  857.     if (result != TCL_OK) {
  858.         goto done;
  859.     }
  860.     }
  861.     while (1) {
  862.     operator = infoPtr->token;
  863.     value2.pv.next = value2.pv.buffer;
  864.     if ((operator < MULT) || (operator >= UNARY_MINUS)) {
  865.         if ((operator == END) || (operator == CLOSE_PAREN)
  866.             || (operator == COMMA)) {
  867.         result = TCL_OK;
  868.         goto done;
  869.         } else {
  870.         goto syntaxError;
  871.         }
  872.     }
  873.     if (precTable[operator] <= prec) {
  874.         result = TCL_OK;
  875.         goto done;
  876.     }
  877.  
  878.     /*
  879.      * If we're doing an AND or OR and the first operand already
  880.      * determines the result, don't execute anything in the
  881.      * second operand:  just parse.  Same style for ?: pairs.
  882.      */
  883.  
  884.     if ((operator == AND) || (operator == OR) || (operator == QUESTY)) {
  885.         if (valuePtr->type == TYPE_DOUBLE) {
  886.         valuePtr->intValue = valuePtr->doubleValue != 0;
  887.         valuePtr->type = TYPE_INT;
  888.         } else if ((valuePtr->type == TYPE_STRING) && !iPtr->noEval) {
  889.         badType = TYPE_STRING;
  890.         goto illegalType;
  891.         }
  892.         if (((operator == AND) && !valuePtr->intValue)
  893.             || ((operator == OR) && valuePtr->intValue)) {
  894.         iPtr->noEval++;
  895.         result = ExprGetValue(interp, infoPtr, precTable[operator],
  896.             &value2);
  897.         iPtr->noEval--;
  898.         if (operator == OR) {
  899.             valuePtr->intValue = 1;
  900.         }
  901.         continue;
  902.         } else if (operator == QUESTY) {
  903.         /*
  904.          * Special note:  ?: operators must associate right to
  905.          * left.  To make this happen, use a precedence one lower
  906.          * than QUESTY when calling ExprGetValue recursively.
  907.          */
  908.  
  909.         if (valuePtr->intValue != 0) {
  910.             valuePtr->pv.next = valuePtr->pv.buffer;
  911.             result = ExprGetValue(interp, infoPtr,
  912.                 precTable[QUESTY] - 1, valuePtr);
  913.             if (result != TCL_OK) {
  914.             goto done;
  915.             }
  916.             if (infoPtr->token != COLON) {
  917.             goto syntaxError;
  918.             }
  919.             value2.pv.next = value2.pv.buffer;
  920.             iPtr->noEval++;
  921.             result = ExprGetValue(interp, infoPtr,
  922.                 precTable[QUESTY] - 1, &value2);
  923.             iPtr->noEval--;
  924.         } else {
  925.             iPtr->noEval++;
  926.             result = ExprGetValue(interp, infoPtr,
  927.                 precTable[QUESTY] - 1, &value2);
  928.             iPtr->noEval--;
  929.             if (result != TCL_OK) {
  930.             goto done;
  931.             }
  932.             if (infoPtr->token != COLON) {
  933.             goto syntaxError;
  934.             }
  935.             valuePtr->pv.next = valuePtr->pv.buffer;
  936.             result = ExprGetValue(interp, infoPtr,
  937.                 precTable[QUESTY] - 1, valuePtr);
  938.         }
  939.         continue;
  940.         } else {
  941.         result = ExprGetValue(interp, infoPtr, precTable[operator],
  942.             &value2);
  943.         }
  944.     } else {
  945.         result = ExprGetValue(interp, infoPtr, precTable[operator],
  946.             &value2);
  947.     }
  948.     if (result != TCL_OK) {
  949.         goto done;
  950.     }
  951.     if ((infoPtr->token < MULT) && (infoPtr->token != VALUE)
  952.         && (infoPtr->token != END) && (infoPtr->token != COMMA)
  953.         && (infoPtr->token != CLOSE_PAREN)) {
  954.         goto syntaxError;
  955.     }
  956.  
  957.     if (iPtr->noEval) {
  958.         continue;
  959.     }
  960.  
  961.     /*
  962.      * At this point we've got two values and an operator.  Check
  963.      * to make sure that the particular data types are appropriate
  964.      * for the particular operator, and perform type conversion
  965.      * if necessary.
  966.      */
  967.  
  968.     switch (operator) {
  969.  
  970.         /*
  971.          * For the operators below, no strings are allowed and
  972.          * ints get converted to floats if necessary.
  973.          */
  974.  
  975.         case MULT: case DIVIDE: case PLUS: case MINUS:
  976.         if ((valuePtr->type == TYPE_STRING)
  977.             || (value2.type == TYPE_STRING)) {
  978.             badType = TYPE_STRING;
  979.             goto illegalType;
  980.         }
  981.         if (valuePtr->type == TYPE_DOUBLE) {
  982.             if (value2.type == TYPE_INT) {
  983.             value2.doubleValue = value2.intValue;
  984.             value2.type = TYPE_DOUBLE;
  985.             }
  986.         } else if (value2.type == TYPE_DOUBLE) {
  987.             if (valuePtr->type == TYPE_INT) {
  988.             valuePtr->doubleValue = valuePtr->intValue;
  989.             valuePtr->type = TYPE_DOUBLE;
  990.             }
  991.         }
  992.         break;
  993.  
  994.         /*
  995.          * For the operators below, only integers are allowed.
  996.          */
  997.  
  998.         case MOD: case LEFT_SHIFT: case RIGHT_SHIFT:
  999.         case BIT_AND: case BIT_XOR: case BIT_OR:
  1000.          if (valuePtr->type != TYPE_INT) {
  1001.              badType = valuePtr->type;
  1002.              goto illegalType;
  1003.          } else if (value2.type != TYPE_INT) {
  1004.              badType = value2.type;
  1005.              goto illegalType;
  1006.          }
  1007.          break;
  1008.  
  1009.         /*
  1010.          * For the operators below, any type is allowed but the
  1011.          * two operands must have the same type.  Convert integers
  1012.          * to floats and either to strings, if necessary.
  1013.          */
  1014.  
  1015.         case LESS: case GREATER: case LEQ: case GEQ:
  1016.         case EQUAL: case NEQ:
  1017.         if (valuePtr->type == TYPE_STRING) {
  1018.             if (value2.type != TYPE_STRING) {
  1019.             ExprMakeString(interp, &value2);
  1020.             }
  1021.         } else if (value2.type == TYPE_STRING) {
  1022.             if (valuePtr->type != TYPE_STRING) {
  1023.             ExprMakeString(interp, valuePtr);
  1024.             }
  1025.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1026.             if (value2.type == TYPE_INT) {
  1027.             value2.doubleValue = value2.intValue;
  1028.             value2.type = TYPE_DOUBLE;
  1029.             }
  1030.         } else if (value2.type == TYPE_DOUBLE) {
  1031.              if (valuePtr->type == TYPE_INT) {
  1032.             valuePtr->doubleValue = valuePtr->intValue;
  1033.             valuePtr->type = TYPE_DOUBLE;
  1034.             }
  1035.         }
  1036.         break;
  1037.  
  1038.         /*
  1039.          * For the operators below, no strings are allowed, but
  1040.          * no int->double conversions are performed.
  1041.          */
  1042.  
  1043.         case AND: case OR:
  1044.         if (valuePtr->type == TYPE_STRING) {
  1045.             badType = valuePtr->type;
  1046.             goto illegalType;
  1047.         }
  1048.         if (value2.type == TYPE_STRING) {
  1049.             badType = value2.type;
  1050.             goto illegalType;
  1051.         }
  1052.         break;
  1053.  
  1054.         /*
  1055.          * For the operators below, type and conversions are
  1056.          * irrelevant:  they're handled elsewhere.
  1057.          */
  1058.  
  1059.         case QUESTY: case COLON:
  1060.         break;
  1061.  
  1062.         /*
  1063.          * Any other operator is an error.
  1064.          */
  1065.  
  1066.         default:
  1067.         interp->result = "unknown operator in expression";
  1068.         result = TCL_ERROR;
  1069.         goto done;
  1070.     }
  1071.  
  1072.     /*
  1073.      * Carry out the function of the specified operator.
  1074.      */
  1075.  
  1076.     switch (operator) {
  1077.         case MULT:
  1078.         if (valuePtr->type == TYPE_INT) {
  1079.             result = valuePtr->intValue * value2.intValue;
  1080.         
  1081.             /*
  1082.              * Check that no overflow occurred in the multiplication
  1083.              */
  1084.         
  1085.             if ((valuePtr->intValue != 0)
  1086.                 && ((result / valuePtr->intValue)
  1087.                 != value2.intValue)) {
  1088.             goto integerOverflow;
  1089.             }
  1090.             valuePtr->intValue = result;
  1091.         } else {
  1092.             valuePtr->doubleValue *= value2.doubleValue;
  1093.         }
  1094.         break;
  1095.         case DIVIDE:
  1096.         case MOD:
  1097.         if (valuePtr->type == TYPE_INT) {
  1098.             long divisor, quot, rem;
  1099.             int negative;
  1100.  
  1101.             if (value2.intValue == 0) {
  1102.             divideByZero:
  1103.             interp->result = "divide by zero";
  1104.             Tcl_SetErrorCode(interp, "ARITH", "DIVZERO",
  1105.                 interp->result, (char *) NULL);
  1106.             result = TCL_ERROR;
  1107.             goto done;
  1108.             }
  1109.             if ((valuePtr->intValue == LONG_MIN) &&
  1110.                 (value2.intValue == -1) && (operator == DIVIDE)) {
  1111.             goto integerOverflow;
  1112.             }
  1113.  
  1114.             /*
  1115.              * The code below is tricky because C doesn't guarantee
  1116.              * much about the properties of the quotient or
  1117.              * remainder, but Tcl does:  the remainder always has
  1118.              * the same sign as the divisor and a smaller absolute
  1119.              * value.
  1120.              */
  1121.  
  1122.             divisor = value2.intValue;
  1123.             negative = 0;
  1124.             if (divisor < 0) {
  1125.             divisor = -divisor;
  1126.             valuePtr->intValue = -valuePtr->intValue;
  1127.             negative = 1;
  1128.             }
  1129.             quot = valuePtr->intValue / divisor;
  1130.             rem = valuePtr->intValue % divisor;
  1131.             if (rem < 0) {
  1132.             rem += divisor;
  1133.             quot -= 1;
  1134.             }
  1135.             if (negative) {
  1136.             rem = -rem;
  1137.             }
  1138.             valuePtr->intValue = (operator == DIVIDE) ? quot : rem;
  1139.         } else {
  1140.             if (value2.doubleValue == 0.0) {
  1141.             goto divideByZero;
  1142.             }
  1143.             valuePtr->doubleValue /= value2.doubleValue;
  1144.         }
  1145.         break;
  1146.         case PLUS:
  1147.         if (valuePtr->type == TYPE_INT) {
  1148.             result = valuePtr->intValue + value2.intValue;
  1149.             if ((value2.intValue >= 0)
  1150.                 ^ (result >= valuePtr->intValue)) {
  1151.             goto integerOverflow;
  1152.             }
  1153.             valuePtr->intValue = result;
  1154.         } else {
  1155.             valuePtr->doubleValue += value2.doubleValue;
  1156.         }
  1157.         break;
  1158.         case MINUS:
  1159.         if (valuePtr->type == TYPE_INT) {
  1160.             result = valuePtr->intValue - value2.intValue;
  1161.             if ((value2.intValue >= 0)
  1162.                 ^ (result <= valuePtr->intValue)) {
  1163.             goto integerOverflow;
  1164.             }
  1165.             valuePtr->intValue = result;
  1166.         } else {
  1167.             valuePtr->doubleValue -= value2.doubleValue;
  1168.         }
  1169.         break;
  1170.         case LEFT_SHIFT:
  1171.         valuePtr->intValue <<= value2.intValue;
  1172.         break;
  1173.         case RIGHT_SHIFT:
  1174.         /*
  1175.          * The following code is a bit tricky:  it ensures that
  1176.          * right shifts propagate the sign bit even on machines
  1177.          * where ">>" won't do it by default.
  1178.          */
  1179.  
  1180.         if (valuePtr->intValue < 0) {
  1181.             valuePtr->intValue =
  1182.                 ~((~valuePtr->intValue) >> value2.intValue);
  1183.         } else {
  1184.             valuePtr->intValue >>= value2.intValue;
  1185.         }
  1186.         break;
  1187.         case LESS:
  1188.         if (valuePtr->type == TYPE_INT) {
  1189.             valuePtr->intValue =
  1190.             valuePtr->intValue < value2.intValue;
  1191.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1192.             valuePtr->intValue =
  1193.             valuePtr->doubleValue < value2.doubleValue;
  1194.         } else {
  1195.             valuePtr->intValue =
  1196.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) < 0;
  1197.         }
  1198.         valuePtr->type = TYPE_INT;
  1199.         break;
  1200.         case GREATER:
  1201.         if (valuePtr->type == TYPE_INT) {
  1202.             valuePtr->intValue =
  1203.             valuePtr->intValue > value2.intValue;
  1204.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1205.             valuePtr->intValue =
  1206.             valuePtr->doubleValue > value2.doubleValue;
  1207.         } else {
  1208.             valuePtr->intValue =
  1209.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) > 0;
  1210.         }
  1211.         valuePtr->type = TYPE_INT;
  1212.         break;
  1213.         case LEQ:
  1214.         if (valuePtr->type == TYPE_INT) {
  1215.             valuePtr->intValue =
  1216.             valuePtr->intValue <= value2.intValue;
  1217.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1218.             valuePtr->intValue =
  1219.             valuePtr->doubleValue <= value2.doubleValue;
  1220.         } else {
  1221.             valuePtr->intValue =
  1222.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) <= 0;
  1223.         }
  1224.         valuePtr->type = TYPE_INT;
  1225.         break;
  1226.         case GEQ:
  1227.         if (valuePtr->type == TYPE_INT) {
  1228.             valuePtr->intValue =
  1229.             valuePtr->intValue >= value2.intValue;
  1230.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1231.             valuePtr->intValue =
  1232.             valuePtr->doubleValue >= value2.doubleValue;
  1233.         } else {
  1234.             valuePtr->intValue =
  1235.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) >= 0;
  1236.         }
  1237.         valuePtr->type = TYPE_INT;
  1238.         break;
  1239.         case EQUAL:
  1240.         if (valuePtr->type == TYPE_INT) {
  1241.             valuePtr->intValue =
  1242.             valuePtr->intValue == value2.intValue;
  1243.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1244.             valuePtr->intValue =
  1245.             valuePtr->doubleValue == value2.doubleValue;
  1246.         } else {
  1247.             valuePtr->intValue =
  1248.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) == 0;
  1249.         }
  1250.         valuePtr->type = TYPE_INT;
  1251.         break;
  1252.         case NEQ:
  1253.         if (valuePtr->type == TYPE_INT) {
  1254.             valuePtr->intValue =
  1255.             valuePtr->intValue != value2.intValue;
  1256.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1257.             valuePtr->intValue =
  1258.             valuePtr->doubleValue != value2.doubleValue;
  1259.         } else {
  1260.             valuePtr->intValue =
  1261.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) != 0;
  1262.         }
  1263.         valuePtr->type = TYPE_INT;
  1264.         break;
  1265.         case BIT_AND:
  1266.         valuePtr->intValue &= value2.intValue;
  1267.         break;
  1268.         case BIT_XOR:
  1269.         valuePtr->intValue ^= value2.intValue;
  1270.         break;
  1271.         case BIT_OR:
  1272.         valuePtr->intValue |= value2.intValue;
  1273.         break;
  1274.  
  1275.         /*
  1276.          * For AND and OR, we know that the first value has already
  1277.          * been converted to an integer.  Thus we need only consider
  1278.          * the possibility of int vs. double for the second value.
  1279.          */
  1280.  
  1281.         case AND:
  1282.         if (value2.type == TYPE_DOUBLE) {
  1283.             value2.intValue = value2.doubleValue != 0;
  1284.             value2.type = TYPE_INT;
  1285.         }
  1286.         valuePtr->intValue = valuePtr->intValue && value2.intValue;
  1287.         break;
  1288.         case OR:
  1289.         if (value2.type == TYPE_DOUBLE) {
  1290.             value2.intValue = value2.doubleValue != 0;
  1291.             value2.type = TYPE_INT;
  1292.         }
  1293.         valuePtr->intValue = valuePtr->intValue || value2.intValue;
  1294.         break;
  1295.  
  1296.         case COLON:
  1297.         interp->result = "can't have : operator without ? first";
  1298.         result = TCL_ERROR;
  1299.         goto done;
  1300.     }
  1301.     }
  1302.  
  1303.     done:
  1304.     if (value2.pv.buffer != value2.staticSpace) {
  1305.     ckfree(value2.pv.buffer);
  1306.     }
  1307.     return result;
  1308.  
  1309.     syntaxError:
  1310.     Tcl_AppendResult(interp, "syntax error in expression \"",
  1311.         infoPtr->originalExpr, "\"", (char *) NULL);
  1312.     result = TCL_ERROR;
  1313.     goto done;
  1314.  
  1315.     illegalType:
  1316.     Tcl_AppendResult(interp, "can't use ", (badType == TYPE_DOUBLE) ?
  1317.         "floating-point value" : "non-numeric string",
  1318.         " as operand of \"", operatorStrings[operator], "\"",
  1319.         (char *) NULL);
  1320.     result = TCL_ERROR;
  1321.     goto done;
  1322.  
  1323.     integerOverflow:
  1324.     interp->result = "integer overflow";
  1325.     Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result,
  1326.         (char *) NULL);
  1327.     result = TCL_ERROR;
  1328.     goto done;
  1329. }
  1330.  
  1331. /*
  1332.  *--------------------------------------------------------------
  1333.  *
  1334.  * ExprMakeString --
  1335.  *
  1336.  *    Convert a value from int or double representation to
  1337.  *    a string.
  1338.  *
  1339.  * Results:
  1340.  *    The information at *valuePtr gets converted to string
  1341.  *    format, if it wasn't that way already.
  1342.  *
  1343.  * Side effects:
  1344.  *    None.
  1345.  *
  1346.  *--------------------------------------------------------------
  1347.  */
  1348.  
  1349. static void
  1350. ExprMakeString(interp, valuePtr)
  1351.     Tcl_Interp *interp;            /* Interpreter to use for precision
  1352.                      * information. */
  1353.     register Value *valuePtr;        /* Value to be converted. */
  1354. {
  1355.     int shortfall;
  1356.  
  1357.     shortfall = 150 - (valuePtr->pv.end - valuePtr->pv.buffer);
  1358.     if (shortfall > 0) {
  1359.     (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall);
  1360.     }
  1361.     if (valuePtr->type == TYPE_INT) {
  1362.     sprintf(valuePtr->pv.buffer, "%ld", valuePtr->intValue);
  1363.     } else if (valuePtr->type == TYPE_DOUBLE) {
  1364.     Tcl_PrintDouble(interp, valuePtr->doubleValue, valuePtr->pv.buffer);
  1365.     }
  1366.     valuePtr->type = TYPE_STRING;
  1367. }
  1368.  
  1369. /*
  1370.  *--------------------------------------------------------------
  1371.  *
  1372.  * ExprTopLevel --
  1373.  *
  1374.  *    This procedure provides top-level functionality shared by
  1375.  *    procedures like Tcl_ExprInt, Tcl_ExprDouble, etc.
  1376.  *
  1377.  * Results:
  1378.  *    The result is a standard Tcl return value.  If an error
  1379.  *    occurs then an error message is left in interp->result.
  1380.  *    The value of the expression is returned in *valuePtr, in
  1381.  *    whatever form it ends up in (could be string or integer
  1382.  *    or double).  Caller may need to convert result.  Caller
  1383.  *    is also responsible for freeing string memory in *valuePtr,
  1384.  *    if any was allocated.
  1385.  *
  1386.  * Side effects:
  1387.  *    None.
  1388.  *
  1389.  *--------------------------------------------------------------
  1390.  */
  1391.  
  1392. static int
  1393. ExprTopLevel(interp, string, valuePtr)
  1394.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1395.                      * expression. */
  1396.     char *string;            /* Expression to evaluate. */
  1397.     Value *valuePtr;            /* Where to store result.  Should
  1398.                      * not be initialized by caller. */
  1399. {
  1400.     ExprInfo info;
  1401.     int result;
  1402.  
  1403.     /*
  1404.      * Create the math functions the first time an expression is
  1405.      * evaluated.
  1406.      */
  1407.  
  1408.     if (!(((Interp *) interp)->flags & EXPR_INITIALIZED)) {
  1409.     BuiltinFunc *funcPtr;
  1410.  
  1411.     ((Interp *) interp)->flags |= EXPR_INITIALIZED;
  1412.     for (funcPtr = funcTable; funcPtr->name != NULL;
  1413.         funcPtr++) {
  1414.         Tcl_CreateMathFunc(interp, funcPtr->name, funcPtr->numArgs,
  1415.             funcPtr->argTypes, funcPtr->proc, funcPtr->clientData);
  1416.     }
  1417.     }
  1418.  
  1419.     info.originalExpr = string;
  1420.     info.expr = string;
  1421.     valuePtr->pv.buffer = valuePtr->pv.next = valuePtr->staticSpace;
  1422.     valuePtr->pv.end = valuePtr->pv.buffer + STATIC_STRING_SPACE - 1;
  1423.     valuePtr->pv.expandProc = TclExpandParseValue;
  1424.     valuePtr->pv.clientData = (ClientData) NULL;
  1425.  
  1426.     result = ExprGetValue(interp, &info, -1, valuePtr);
  1427.     if (result != TCL_OK) {
  1428.     return result;
  1429.     }
  1430.     if (info.token != END) {
  1431.     Tcl_AppendResult(interp, "syntax error in expression \"",
  1432.         string, "\"", (char *) NULL);
  1433.     return TCL_ERROR;
  1434.     }
  1435.     if ((valuePtr->type == TYPE_DOUBLE) && (IS_NAN(valuePtr->doubleValue)
  1436.         || IS_INF(valuePtr->doubleValue))) {
  1437.     /*
  1438.      * IEEE floating-point error.
  1439.      */
  1440.  
  1441.     TclExprFloatError(interp, valuePtr->doubleValue);
  1442.     return TCL_ERROR;
  1443.     }
  1444.     return TCL_OK;
  1445. }
  1446.  
  1447. /*
  1448.  *--------------------------------------------------------------
  1449.  *
  1450.  * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
  1451.  *
  1452.  *    Procedures to evaluate an expression and return its value
  1453.  *    in a particular form.
  1454.  *
  1455.  * Results:
  1456.  *    Each of the procedures below returns a standard Tcl result.
  1457.  *    If an error occurs then an error message is left in
  1458.  *    interp->result.  Otherwise the value of the expression,
  1459.  *    in the appropriate form, is stored at *resultPtr.  If
  1460.  *    the expression had a result that was incompatible with the
  1461.  *    desired form then an error is returned.
  1462.  *
  1463.  * Side effects:
  1464.  *    None.
  1465.  *
  1466.  *--------------------------------------------------------------
  1467.  */
  1468.  
  1469. int
  1470. Tcl_ExprLong(interp, string, ptr)
  1471.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1472.                      * expression. */
  1473.     char *string;            /* Expression to evaluate. */
  1474.     long *ptr;                /* Where to store result. */
  1475. {
  1476.     Value value;
  1477.     int result;
  1478.  
  1479.     result = ExprTopLevel(interp, string, &value);
  1480.     if (result == TCL_OK) {
  1481.     if (value.type == TYPE_INT) {
  1482.         *ptr = value.intValue;
  1483.     } else if (value.type == TYPE_DOUBLE) {
  1484.         *ptr = value.doubleValue;
  1485.     } else {
  1486.         interp->result = "expression didn't have numeric value";
  1487.         result = TCL_ERROR;
  1488.     }
  1489.     }
  1490.     if (value.pv.buffer != value.staticSpace) {
  1491.     ckfree(value.pv.buffer);
  1492.     }
  1493.     return result;
  1494. }
  1495.  
  1496. int
  1497. Tcl_ExprDouble(interp, string, ptr)
  1498.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1499.                      * expression. */
  1500.     char *string;            /* Expression to evaluate. */
  1501.     double *ptr;            /* Where to store result. */
  1502. {
  1503.     Value value;
  1504.     int result;
  1505.  
  1506.     result = ExprTopLevel(interp, string, &value);
  1507.     if (result == TCL_OK) {
  1508.     if (value.type == TYPE_INT) {
  1509.         *ptr = value.intValue;
  1510.     } else if (value.type == TYPE_DOUBLE) {
  1511.         *ptr = value.doubleValue;
  1512.     } else {
  1513.         interp->result = "expression didn't have numeric value";
  1514.         result = TCL_ERROR;
  1515.     }
  1516.     }
  1517.     if (value.pv.buffer != value.staticSpace) {
  1518.     ckfree(value.pv.buffer);
  1519.     }
  1520.     return result;
  1521. }
  1522.  
  1523. int
  1524. Tcl_ExprBoolean(interp, string, ptr)
  1525.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1526.                      * expression. */
  1527.     char *string;            /* Expression to evaluate. */
  1528.     int *ptr;                /* Where to store 0/1 result. */
  1529. {
  1530.     Value value;
  1531.     int result;
  1532.  
  1533.     result = ExprTopLevel(interp, string, &value);
  1534.     if (result == TCL_OK) {
  1535.     if (value.type == TYPE_INT) {
  1536.         *ptr = value.intValue != 0;
  1537.     } else if (value.type == TYPE_DOUBLE) {
  1538.         *ptr = value.doubleValue != 0.0;
  1539.     } else {
  1540.         result = Tcl_GetBoolean(interp, value.pv.buffer, ptr);
  1541.     }
  1542.     }
  1543.     if (value.pv.buffer != value.staticSpace) {
  1544.     ckfree(value.pv.buffer);
  1545.     }
  1546.     return result;
  1547. }
  1548.  
  1549. /*
  1550.  *--------------------------------------------------------------
  1551.  *
  1552.  * Tcl_ExprString --
  1553.  *
  1554.  *    Evaluate an expression and return its value in string form.
  1555.  *
  1556.  * Results:
  1557.  *    A standard Tcl result.  If the result is TCL_OK, then the
  1558.  *    interpreter's result is set to the string value of the
  1559.  *    expression.  If the result is TCL_OK, then interp->result
  1560.  *    contains an error message.
  1561.  *
  1562.  * Side effects:
  1563.  *    None.
  1564.  *
  1565.  *--------------------------------------------------------------
  1566.  */
  1567.  
  1568. int
  1569. Tcl_ExprString(interp, string)
  1570.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1571.                      * expression. */
  1572.     char *string;            /* Expression to evaluate. */
  1573. {
  1574.     Value value;
  1575.     int result;
  1576.  
  1577.     result = ExprTopLevel(interp, string, &value);
  1578.     if (result == TCL_OK) {
  1579.     if (value.type == TYPE_INT) {
  1580.         sprintf(interp->result, "%ld", value.intValue);
  1581.     } else if (value.type == TYPE_DOUBLE) {
  1582.         Tcl_PrintDouble(interp, value.doubleValue, interp->result);
  1583.     } else {
  1584.         if (value.pv.buffer != value.staticSpace) {
  1585.         interp->result = value.pv.buffer;
  1586.         interp->freeProc = (Tcl_FreeProc *) free;
  1587.         value.pv.buffer = value.staticSpace;
  1588.         } else {
  1589.         Tcl_SetResult(interp, value.pv.buffer, TCL_VOLATILE);
  1590.         }
  1591.     }
  1592.     }
  1593.     if (value.pv.buffer != value.staticSpace) {
  1594.     ckfree(value.pv.buffer);
  1595.     }
  1596.     return result;
  1597. }
  1598.  
  1599. /*
  1600.  *----------------------------------------------------------------------
  1601.  *
  1602.  * Tcl_CreateMathFunc --
  1603.  *
  1604.  *    Creates a new math function for expressions in a given
  1605.  *    interpreter.
  1606.  *
  1607.  * Results:
  1608.  *    None.
  1609.  *
  1610.  * Side effects:
  1611.  *    The function defined by "name" is created;  if such a function
  1612.  *    already existed then its definition is overriden.
  1613.  *
  1614.  *----------------------------------------------------------------------
  1615.  */
  1616.  
  1617. void
  1618. Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
  1619.     Tcl_Interp *interp;            /* Interpreter in which function is
  1620.                      * to be available. */
  1621.     char *name;                /* Name of function (e.g. "sin"). */
  1622.     int numArgs;            /* Nnumber of arguments required by
  1623.                      * function. */
  1624.     Tcl_ValueType *argTypes;        /* Array of types acceptable for
  1625.                      * each argument. */
  1626.     Tcl_MathProc *proc;            /* Procedure that implements the
  1627.                      * math function. */
  1628.     ClientData clientData;        /* Additional value to pass to the
  1629.                      * function. */
  1630. {
  1631.     Interp *iPtr = (Interp *) interp;
  1632.     Tcl_HashEntry *hPtr;
  1633.     MathFunc *mathFuncPtr;
  1634.     int new, i;
  1635.  
  1636.     hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
  1637.     if (new) {
  1638.     Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
  1639.     }
  1640.     mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
  1641.     if (numArgs > MAX_MATH_ARGS) {
  1642.     numArgs = MAX_MATH_ARGS;
  1643.     }
  1644.     mathFuncPtr->numArgs = numArgs;
  1645.     for (i = 0; i < numArgs; i++) {
  1646.     mathFuncPtr->argTypes[i] = argTypes[i];
  1647.     }
  1648.     mathFuncPtr->proc = proc;
  1649.     mathFuncPtr->clientData = clientData;
  1650. }
  1651.  
  1652. /*
  1653.  *----------------------------------------------------------------------
  1654.  *
  1655.  * ExprMathFunc --
  1656.  *
  1657.  *    This procedure is invoked to parse a math function from an
  1658.  *    expression string, carry out the function, and return the
  1659.  *    value computed.
  1660.  *
  1661.  * Results:
  1662.  *    TCL_OK is returned if all went well and the function's value
  1663.  *    was computed successfully.  If an error occurred, TCL_ERROR
  1664.  *    is returned and an error message is left in interp->result.
  1665.  *    After a successful return infoPtr has been updated to refer
  1666.  *    to the character just after the function call, the token is
  1667.  *    set to VALUE, and the value is stored in valuePtr.
  1668.  *
  1669.  * Side effects:
  1670.  *    Embedded commands could have arbitrary side-effects.
  1671.  *
  1672.  *----------------------------------------------------------------------
  1673.  */
  1674.  
  1675. static int
  1676. ExprMathFunc(interp, infoPtr, valuePtr)
  1677.     Tcl_Interp *interp;            /* Interpreter to use for error
  1678.                      * reporting. */
  1679.     register ExprInfo *infoPtr;        /* Describes the state of the parse.
  1680.                      * infoPtr->expr must point to the
  1681.                      * first character of the function's
  1682.                      * name. */
  1683.     register Value *valuePtr;        /* Where to store value, if that is
  1684.                      * what's parsed from string.  Caller
  1685.                      * must have initialized pv field
  1686.                      * correctly. */
  1687. {
  1688.     Interp *iPtr = (Interp *) interp;
  1689.     MathFunc *mathFuncPtr;        /* Info about math function. */
  1690.     Tcl_Value args[MAX_MATH_ARGS];    /* Arguments for function call. */
  1691.     Tcl_Value funcResult;        /* Result of function call. */
  1692.     Tcl_HashEntry *hPtr;
  1693.     char *p, *funcName;
  1694.     int i, savedChar, result;
  1695.  
  1696.     /*
  1697.      * Find the end of the math function's name and lookup the MathFunc
  1698.      * record for the function.
  1699.      */
  1700.  
  1701.     p = funcName = infoPtr->expr;
  1702.     while (isalnum(UCHAR(*p)) || (*p == '_')) {
  1703.     p++;
  1704.     }
  1705.     infoPtr->expr = p;
  1706.     result = ExprLex(interp, infoPtr, valuePtr);
  1707.     if (result != TCL_OK) {
  1708.     return TCL_ERROR;
  1709.     }
  1710.     if (infoPtr->token != OPEN_PAREN) {
  1711.     goto syntaxError;
  1712.     }
  1713.     savedChar = *p;
  1714.     *p = 0;
  1715.     hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
  1716.     if (hPtr == NULL) {
  1717.     Tcl_AppendResult(interp, "unknown math function \"", funcName,
  1718.         "\"", (char *) NULL);
  1719.     *p = savedChar;
  1720.     return TCL_ERROR;
  1721.     }
  1722.     *p = savedChar;
  1723.     mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
  1724.  
  1725.     /*
  1726.      * Scan off the arguments for the function, if there are any.
  1727.      */
  1728.  
  1729.     if (mathFuncPtr->numArgs == 0) {
  1730.     result = ExprLex(interp, infoPtr, valuePtr);
  1731.     if ((result != TCL_OK) || (infoPtr->token != CLOSE_PAREN)) {
  1732.         goto syntaxError;
  1733.     }
  1734.     } else {
  1735.     for (i = 0; ; i++) {
  1736.         valuePtr->pv.next = valuePtr->pv.buffer;
  1737.         result = ExprGetValue(interp, infoPtr, -1, valuePtr);
  1738.         if (result != TCL_OK) {
  1739.         return result;
  1740.         }
  1741.         if (valuePtr->type == TYPE_STRING) {
  1742.         interp->result =
  1743.             "argument to math function didn't have numeric value";
  1744.         return TCL_ERROR;
  1745.         }
  1746.     
  1747.         /*
  1748.          * Copy the value to the argument record, converting it if
  1749.          * necessary.
  1750.          */
  1751.     
  1752.         if (valuePtr->type == TYPE_INT) {
  1753.         if (mathFuncPtr->argTypes[i] == TCL_DOUBLE) {
  1754.             args[i].type = TCL_DOUBLE;
  1755.             args[i].doubleValue = valuePtr->intValue;
  1756.         } else {
  1757.             args[i].type = TCL_INT;
  1758.             args[i].intValue = valuePtr->intValue;
  1759.         }
  1760.         } else {
  1761.         if (mathFuncPtr->argTypes[i] == TCL_INT) {
  1762.             args[i].type = TCL_INT;
  1763.             args[i].intValue = valuePtr->doubleValue;
  1764.         } else {
  1765.             args[i].type = TCL_DOUBLE;
  1766.             args[i].doubleValue = valuePtr->doubleValue;
  1767.         }
  1768.         }
  1769.     
  1770.         /*
  1771.          * Check for a comma separator between arguments or a close-paren
  1772.          * to end the argument list.
  1773.          */
  1774.     
  1775.         if (i == (mathFuncPtr->numArgs-1)) {
  1776.         if (infoPtr->token == CLOSE_PAREN) {
  1777.             break;
  1778.         }
  1779.         if (infoPtr->token == COMMA) {
  1780.             interp->result = "too many arguments for math function";
  1781.             return TCL_ERROR;
  1782.         } else {
  1783.             goto syntaxError;
  1784.         }
  1785.         }
  1786.         if (infoPtr->token != COMMA) {
  1787.         if (infoPtr->token == CLOSE_PAREN) {
  1788.             interp->result = "too few arguments for math function";
  1789.             return TCL_ERROR;
  1790.         } else {
  1791.             goto syntaxError;
  1792.         }
  1793.         }
  1794.     }
  1795.     }
  1796.     if (iPtr->noEval) {
  1797.     valuePtr->type = TYPE_INT;
  1798.     valuePtr->intValue = 0;
  1799.     infoPtr->token = VALUE;
  1800.     return TCL_OK;
  1801.     }
  1802.  
  1803.     /*
  1804.      * Invoke the function and copy its result back into valuePtr.
  1805.      */
  1806.  
  1807.     tcl_MathInProgress++;
  1808.     result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
  1809.         &funcResult);
  1810.     tcl_MathInProgress--;
  1811.     if (result != TCL_OK) {
  1812.     return result;
  1813.     }
  1814.     if (funcResult.type == TCL_INT) {
  1815.     valuePtr->type = TYPE_INT;
  1816.     valuePtr->intValue = funcResult.intValue;
  1817.     } else {
  1818.     valuePtr->type = TYPE_DOUBLE;
  1819.     valuePtr->doubleValue = funcResult.doubleValue;
  1820.     }
  1821.     infoPtr->token = VALUE;
  1822.     return TCL_OK;
  1823.  
  1824.     syntaxError:
  1825.     Tcl_AppendResult(interp, "syntax error in expression \"",
  1826.         infoPtr->originalExpr, "\"", (char *) NULL);
  1827.     return TCL_ERROR;
  1828. }
  1829.  
  1830. /*
  1831.  *----------------------------------------------------------------------
  1832.  *
  1833.  * TclExprFloatError --
  1834.  *
  1835.  *    This procedure is called when an error occurs during a
  1836.  *    floating-point operation.  It reads errno and sets
  1837.  *    interp->result accordingly.
  1838.  *
  1839.  * Results:
  1840.  *    Interp->result is set to hold an error message.
  1841.  *
  1842.  * Side effects:
  1843.  *    None.
  1844.  *
  1845.  *----------------------------------------------------------------------
  1846.  */
  1847.  
  1848. void
  1849. TclExprFloatError(interp, value)
  1850.     Tcl_Interp *interp;        /* Where to store error message. */
  1851.     double value;        /* Value returned after error;  used to
  1852.                  * distinguish underflows from overflows. */
  1853. {
  1854.     char buf[20];
  1855.  
  1856.     if ((errno == EDOM) || (value != value)) {
  1857.     interp->result = "domain error: argument not in valid range";
  1858.     Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", interp->result,
  1859.         (char *) NULL);
  1860.     } else if ((errno == ERANGE) || IS_INF(value)) {
  1861.     if (value == 0.0) {
  1862.         interp->result = "floating-point value too small to represent";
  1863.         Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", interp->result,
  1864.             (char *) NULL);
  1865.     } else {
  1866.         interp->result = "floating-point value too large to represent";
  1867.         Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", interp->result,
  1868.             (char *) NULL);
  1869.     }
  1870.     } else {
  1871.     sprintf(buf, "%d", errno);
  1872.     Tcl_AppendResult(interp, "unknown floating-point error, ",
  1873.         "errno = ", buf, (char *) NULL);
  1874.     Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", interp->result,
  1875.         (char *) NULL);
  1876.     }
  1877. }
  1878.  
  1879. /*
  1880.  *----------------------------------------------------------------------
  1881.  *
  1882.  * Math Functions --
  1883.  *
  1884.  *    This page contains the procedures that implement all of the
  1885.  *    built-in math functions for expressions.
  1886.  *
  1887.  * Results:
  1888.  *    Each procedure returns TCL_OK if it succeeds and places result
  1889.  *    information at *resultPtr.  If it fails it returns TCL_ERROR
  1890.  *    and leaves an error message in interp->result.
  1891.  *
  1892.  * Side effects:
  1893.  *    None.
  1894.  *
  1895.  *----------------------------------------------------------------------
  1896.  */
  1897.  
  1898. static int
  1899. ExprUnaryFunc(clientData, interp, args, resultPtr)
  1900.     ClientData clientData;        /* Contains address of procedure that
  1901.                      * takes one double argument and
  1902.                      * returns a double result. */
  1903.     Tcl_Interp *interp;
  1904.     Tcl_Value *args;
  1905.     Tcl_Value *resultPtr;
  1906. {
  1907.     double (*func)() = (double (*)()) clientData;
  1908.  
  1909.     errno = 0;
  1910.     resultPtr->type = TCL_DOUBLE;
  1911.     resultPtr->doubleValue = (*func)(args[0].doubleValue);
  1912.     if (errno != 0) {
  1913.     TclExprFloatError(interp, resultPtr->doubleValue);
  1914.     return TCL_ERROR;
  1915.     }
  1916.     return TCL_OK;
  1917. }
  1918.  
  1919. static int
  1920. ExprBinaryFunc(clientData, interp, args, resultPtr)
  1921.     ClientData clientData;        /* Contains address of procedure that
  1922.                      * takes two double arguments and
  1923.                      * returns a double result. */
  1924.     Tcl_Interp *interp;
  1925.     Tcl_Value *args;
  1926.     Tcl_Value *resultPtr;
  1927. {
  1928.     double (*func)() = (double (*)()) clientData;
  1929.  
  1930.     errno = 0;
  1931.     resultPtr->type = TCL_DOUBLE;
  1932.     resultPtr->doubleValue = (*func)(args[0].doubleValue, args[1].doubleValue);
  1933.     if (errno != 0) {
  1934.     TclExprFloatError(interp, resultPtr->doubleValue);
  1935.     return TCL_ERROR;
  1936.     }
  1937.     return TCL_OK;
  1938. }
  1939.  
  1940.     /* ARGSUSED */
  1941. static int
  1942. ExprAbsFunc(clientData, interp, args, resultPtr)
  1943.     ClientData clientData;
  1944.     Tcl_Interp *interp;
  1945.     Tcl_Value *args;
  1946.     Tcl_Value *resultPtr;
  1947. {
  1948.     resultPtr->type = TCL_DOUBLE;
  1949.     if (args[0].type == TCL_DOUBLE) {
  1950.     resultPtr->type = TCL_DOUBLE;
  1951.     if (args[0].doubleValue < 0) {
  1952.         resultPtr->doubleValue = -args[0].doubleValue;
  1953.     } else {
  1954.         resultPtr->doubleValue = args[0].doubleValue;
  1955.     }
  1956.     } else {
  1957.     resultPtr->type = TCL_INT;
  1958.     if (args[0].intValue < 0) {
  1959.         resultPtr->intValue = -args[0].intValue;
  1960.         if (resultPtr->intValue < 0) {
  1961.         interp->result = "integer value too large to represent";
  1962.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result,
  1963.             (char *) NULL);
  1964.         return TCL_ERROR;
  1965.         }
  1966.     } else {
  1967.         resultPtr->intValue = args[0].intValue;
  1968.     }
  1969.     }
  1970.     return TCL_OK;
  1971. }
  1972.  
  1973.     /* ARGSUSED */
  1974. static int
  1975. ExprDoubleFunc(clientData, interp, args, resultPtr)
  1976.     ClientData clientData;
  1977.     Tcl_Interp *interp;
  1978.     Tcl_Value *args;
  1979.     Tcl_Value *resultPtr;
  1980. {
  1981.     resultPtr->type = TCL_DOUBLE;
  1982.     if (args[0].type == TCL_DOUBLE) {
  1983.     resultPtr->doubleValue = args[0].doubleValue;
  1984.     } else {
  1985.     resultPtr->doubleValue = args[0].intValue;
  1986.     }
  1987.     return TCL_OK;
  1988. }
  1989.  
  1990.     /* ARGSUSED */
  1991. static int
  1992. ExprIntFunc(clientData, interp, args, resultPtr)
  1993.     ClientData clientData;
  1994.     Tcl_Interp *interp;
  1995.     Tcl_Value *args;
  1996.     Tcl_Value *resultPtr;
  1997. {
  1998.     resultPtr->type = TCL_INT;
  1999.     if (args[0].type == TCL_INT) {
  2000.     resultPtr->intValue = args[0].intValue;
  2001.     } else {
  2002.     if (args[0].doubleValue < 0) {
  2003.         if (args[0].doubleValue < (double) (long) LONG_MIN) {
  2004.         tooLarge:
  2005.         interp->result = "integer value too large to represent";
  2006.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
  2007.             interp->result, (char *) NULL);
  2008.         return TCL_ERROR;
  2009.         }
  2010.     } else {
  2011.         if (args[0].doubleValue > (double) LONG_MAX) {
  2012.         goto tooLarge;
  2013.         }
  2014.     }
  2015.     resultPtr->intValue = args[0].doubleValue;
  2016.     }
  2017.     return TCL_OK;
  2018. }
  2019.  
  2020.     /* ARGSUSED */
  2021. static int
  2022. ExprRoundFunc(clientData, interp, args, resultPtr)
  2023.     ClientData clientData;
  2024.     Tcl_Interp *interp;
  2025.     Tcl_Value *args;
  2026.     Tcl_Value *resultPtr;
  2027. {
  2028.     resultPtr->type = TCL_INT;
  2029.     if (args[0].type == TCL_INT) {
  2030.     resultPtr->intValue = args[0].intValue;
  2031.     } else {
  2032.     if (args[0].doubleValue < 0) {
  2033.         if (args[0].doubleValue <= (((double) (long) LONG_MIN) - 0.5)) {
  2034.         tooLarge:
  2035.         interp->result = "integer value too large to represent";
  2036.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
  2037.             interp->result, (char *) NULL);
  2038.         return TCL_ERROR;
  2039.         }
  2040.         resultPtr->intValue = (args[0].doubleValue - 0.5);
  2041.     } else {
  2042.         if (args[0].doubleValue >= (((double) LONG_MAX + 0.5))) {
  2043.         goto tooLarge;
  2044.         }
  2045.         resultPtr->intValue = (args[0].doubleValue + 0.5);
  2046.     }
  2047.     }
  2048.     return TCL_OK;
  2049. }
  2050.  
  2051. /*
  2052.  *----------------------------------------------------------------------
  2053.  *
  2054.  * ExprLooksLikeInt --
  2055.  *
  2056.  *    This procedure decides whether the leading characters of a
  2057.  *    string look like an integer or something else (such as a
  2058.  *    floating-point number or string).
  2059.  *
  2060.  * Results:
  2061.  *    The return value is 1 if the leading characters of p look
  2062.  *    like a valid Tcl integer.  If they look like a floating-point
  2063.  *    number (e.g. "e01" or "2.4"), or if they don't look like a
  2064.  *    number at all, then 0 is returned.
  2065.  *
  2066.  * Side effects:
  2067.  *    None.
  2068.  *
  2069.  *----------------------------------------------------------------------
  2070.  */
  2071.  
  2072. static int
  2073. ExprLooksLikeInt(p)
  2074.     char *p;            /* Pointer to string. */
  2075. {
  2076.     while (isspace(UCHAR(*p))) {
  2077.     p++;
  2078.     }
  2079.     if ((*p == '+') || (*p == '-')) {
  2080.     p++;
  2081.     }
  2082.     if (!isdigit(UCHAR(*p))) {
  2083.     return 0;
  2084.     }
  2085.     p++;
  2086.     while (isdigit(UCHAR(*p))) {
  2087.     p++;
  2088.     }
  2089.     if ((*p != '.') && (*p != 'e') && (*p != 'E')) {
  2090.     return 1;
  2091.     }
  2092.     return 0;
  2093. }
  2094.